perm filename DELETE.SAI[PNT,HE]1 blob
sn#327517 filedate 1978-01-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00011 ENDMK
C⊗;
ENTRY;
BEGIN
REQUIRE "MACROS.SAI[PNT,HE]" SOURCE_FILE;
REQUIRE "RECORD.DEF[PNT,HE]" SOURCE_FILE;
EXTERNAL STRING TOKEN;
EXTERNAL INTEGER $HELP,$LAST;
EXTERNAL PROCEDURE GTOKEN(BOOLEAN REPEAT);
EXTERNAL STRING $TRLST,$FRLST,$SCLST,$VTLST,$RTLST,$OULST,$DFLST;
EXTERNAL INTEGER $ALLOW; ! when >0 no display updating;
EXTERNAL PROCEDURE ABORT1(STRING S1,S2(NULL));
EXTERNAL SIMPLE BOOLEAN PROCEDURE FINAL;
EXTERNAL PROCEDURE ESC_P;
EXTERNAL PROCEDURE KILLVAR(STRING XX);
EXTERNAL SIMPLE STRING PROCEDURE IDF_READ;
EXTERNAL STRING ARRAY $SYNMSG[0:34];
EXTERNAL STRING ARRAY $SEMSG[0:13];
EXTERNAL BOOLEAN STOKEN;
EXTERNAL PROCEDURE ERROR(STRING ERR1,ERR2(NULL));
EXTERNAL PROCEDURE UPDATE;
EXTERNAL RPTR(SYMBOL) PROCEDURE ENSYM(STRING SYMB;INTEGER NM;RANY VAL);
EXTERNAL RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PROCEDURE MK_REC(INTEGER TYPE);
EXTERNAL PROCEDURE UNLINK(RPTR(FRAME) N);
EXTERNAL RPTR(TRANS) PROCEDURE DOTREXP(REAL W,PH,TH,X,Y,Z);
EXTERNAL PROCEDURE AFX_NODE(RPTR(FRAME)N,D;INTEGER HOW);
PROCEDURE RESET;
BEGIN
INTEGER IND,I,TEMP;INTEGER ARRAY SAVE[#MIN:#MAX];RPTR(FRAME)WHAT;
IFC #KILL THENC $LAST←0;ENDC ! unkillable instruction;
SAVE[#SC]←2; ! 2 scalars predefined in the system;
SAVE[#VT]←4; ! 4 vectors;
SAVE[#RT]←1; ! 1 rotation;
SAVE[#FR]←5; ! 5 frames;
SAVE[#TR]←1; ! 1 trans;
FOR IND←#MIN STEP 1 UNTIL #MAX DO
BEGIN
! deletes the records defined for each type saving the predefined ones;
TEMP←$ENTRY[IND]-1;
FOR I←#LTYPE*(IND-#MIN)+SAVE[IND] STEP 1 UNTIL TEMP DO
$YMTAB[I]←NULL_RECORD;
$ENTRY[IND]←#LTYPE*(IND-#MIN)+SAVE[IND]; ! remembers the new $ENTRY to $YMTAB;
END;
! updates the frame tree structure;
$ALLOW←$ALLOW+1;
! kills the sons of WORLD,unless the predefined ones;
WHAT←FRAME:SON[F_WRLD];
WHILE WHAT AND WHAT≠F_BARM AND WHAT≠F_YARM AND WHAT≠F_BPARK AND WHAT≠F_YPARK
DO BEGIN
UNLINK(WHAT);
WHAT←FRAME:SON[F_WRLD];
END;
! kills the sons of BARM and YARM;
FRAME:SON[F_BARM]←FRAME:SON[F_YARM]←NULL_RECORD;
F_FID←F_POINTER←F_BGRASP←NULL_RECORD;
! clears BARM to define again BGRASP and POINTER, then read_barm;
ARRTRAN(FRAME:XF[F_BARM],TRANS:XF[T_NILTRANS]);
! defines again BGRASP;
FRAME:PNAME[SYMBOL:OBJECT[BGRASP←ENSYM("BGRASP",#FR,F_BGRASP←MK_REC(#FR))]]
←"BGRASP";
ARRTRAN(FRAME:XF[F_BGRASP],TRANS:XF[DOTREXP(-180,180,0,0,0,0)]);
AFX_NODE(F_BGRASP,F_BARM,#RGDLK);
! defines again POINTER;
FRAME:PNAME[SYMBOL:OBJECT[POINTER←ENSYM("POINTER",#FR,F_POINTER←MK_REC(#FR))]]
←"POINTER";
ARRTRAN(FRAME:XF[F_POINTER],
TRANS:XF[DOTREXP(-.417,13.2,-5.173,.0121,.119,3.75)]);
AFX_NODE(F_POINTER,F_BARM,#RGDLK);
F_ARM←F_BARM;
! updates the arm position;
READARM(F_BARM);
$ALLOW←$ALLOW-1;
$SCLST←$VTLST←$RTLST←$FRLST←$TRLST←NULL;
IFC #DISPL THENC UPDATE;ENDC
END;
INTERNAL PROCEDURE DELETEPROC;
BEGIN
STRING VAR;
$HELP←1;
GTOKEN(FALSE);
IF FINAL
THEN BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ABORT1($SEMSG[13]);
END
ELSE BEGIN
STOKEN←TRUE;
$ALLOW←$ALLOW+1;
DO BEGIN "A"
VAR←IDF_READ;
KILLVAR(TOKEN);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL
THEN BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR($SYNMSG[1],$SYNMSG[25] );
END;
END "A"
UNTIL FINAL;
$ALLOW←$ALLOW-1;
IFC #DISPL THENC UPDATE;ENDC
END;
END;
END;